home *** CD-ROM | disk | FTP | other *** search
/ Gigarom 1 / Gigarom Macintosh Archives (Quantum Leap)(CDRM1080320)(1993).iso / FILES / DEV / I-Z / XLisp_1.6.cpt / Turtle.LISP < prev    next >
Lisp/Scheme  |  1985-06-20  |  3KB  |  120 lines
  1. ; This is a sample XLISP program.
  2. ; It implements a simple form of programmable turtle
  3.  
  4. ; To run it:
  5.  
  6. ;    (load "pt.lsp")
  7.  
  8. ; This should cause the screen to be cleared and two turtles to appear.
  9. ; They should each execute their simple programs and then the prompt
  10. ; should return.  Look at the code to see how all of this works.
  11.  
  12. ; Get some more memory
  13. (expand 1)
  14.  
  15. ; ::::::::::::
  16. ; :: Turtle ::
  17. ; ::::::::::::
  18.  
  19. ; Define "Turtle" class
  20. (setq Turtle (Class :new '(xpos ypos)))
  21.  
  22. ; Answer ":isnew" by initing a position and char and displaying.
  23. (Turtle :answer :isnew '(x y) '(
  24.     (setq xpos x)
  25.     (setq ypos y)
  26.     (self :display)
  27.     self))
  28.  
  29. ; Message ":display" prints its char at its current position
  30. (Turtle :answer :display '() '(
  31.     (moveto xpos ypos)
  32.     (lineto xpos ypos)
  33.     self))
  34.  
  35. ; Message ":goto" goes to a new place after clearing old one
  36. (Turtle :answer :goto '(x y) '(
  37.     (moveto xpos ypos)
  38.     (setq xpos x)
  39.     (setq ypos y)
  40.     (lineto xpos ypos)
  41.     self))
  42.  
  43. ; Message ":up" moves up
  44. (Turtle :answer :up '() '(
  45.     (self :goto xpos (- ypos 10))))
  46.  
  47. ; Message ":down" moves down
  48. (Turtle :answer :down '() '(
  49.     (self :goto xpos (+ ypos 10))))
  50.  
  51. ; Message ":right" moves right
  52. (Turtle :answer :right '() '(
  53.     (self :goto (+ xpos 10) ypos)))
  54.  
  55. ; Message ":left" moves left
  56. (Turtle :answer :left '() '(
  57.     (self :goto (- xpos 10) ypos)))
  58.  
  59.  
  60. ; :::::::::::::
  61. ; :: PTurtle ::
  62. ; :::::::::::::
  63.  
  64. ; Define "DPurtle" programable turtle class
  65. (setq PTurtle (Class :new '(prog pc) '() Turtle))
  66.  
  67. ; Message ":program" stores a program
  68. (PTurtle :answer :program '(p) '(
  69.     (setq prog p)
  70.     (setq pc prog)
  71.     self))
  72.  
  73. ; Message ":step" executes a single program step
  74. (PTurtle :answer :step '() '(
  75.     (if (null pc)
  76.     (setq pc prog))
  77.     (if pc
  78.     (progn (self (car pc))
  79.            (setq pc (cdr pc))))
  80.     self))
  81.  
  82. ; Message ":step:" steps each turtle program n times
  83. (PTurtle :answer :step: '(n) '(
  84.     (dotimes (x n) (self :step))
  85.     self))
  86.  
  87.  
  88. ; ::::::::::::::
  89. ; :: PTurtles ::
  90. ; ::::::::::::::
  91.  
  92. ; Define "PTurtles" class
  93. (setq PTurtles (Class :new '(turtles)))
  94.  
  95. ; Message ":make" makes a programable turtle and adds it to the collection
  96. (PTurtles :answer :make '(x y &aux newturtle) '(
  97.     (setq newturtle (PTurtle :new x y))
  98.     (setq turtles (cons newturtle turtles))
  99.     newturtle))
  100.  
  101. ; Message ":step" steps each turtle program once
  102. (PTurtles :answer :step '() '(
  103.     (mapcar #'(lambda (turtle) (turtle :step)) turtles)
  104.     self))
  105.  
  106. ; Message ":step:" steps each turtle program n times
  107. (PTurtles :answer :step: '(n) '(
  108.     (dotimes (x n) (self :step))
  109.     self))
  110.  
  111.  
  112. ; Create some programmable turtles
  113. (setq turtles (PTurtles :new))
  114. (setq t1 (turtles :make 200 100))
  115. (setq t2 (turtles :make 210 100))
  116. (t1 :program '(:left :left :up :right :up))
  117. (t2 :program '(:right :right :down :left :down))
  118. (show-graphics)
  119. (turtles :step: 10)
  120.